home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0100_Fade and Palette Routines.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-09  |  2KB  |  91 lines
  1.  
  2. {$M 16384,0,255360}
  3. uses Dos,crt;
  4.  
  5. procedure waitretrace;assembler; {wait for next vertical retrace}
  6. asm
  7.   mov dx,$3DA
  8.   @V1: in al,dx; test al,8; jz @v1;
  9.   @V2: in al,dx; test al,8; jnz @v2;
  10. end;
  11.  
  12. type
  13.   rgb = record r, g, b : byte; end;
  14.   paltype = array[0..255]of rgb;
  15. var
  16.   i : integer;
  17.   pal : paltype;
  18.  
  19. procedure get_color(var pal : paltype); {save palette}
  20. var
  21.   i : integer;
  22. begin
  23.   port[$3C7] := $00;
  24.   for i:= 0 to 255 do begin
  25.     pal[i].r := port[$3C9];
  26.     pal[i].g := port[$3C9];
  27.     pal[i].b := port[$3C9];
  28.   end;
  29. end;
  30.  
  31. procedure set_intensity(intensity : byte);
  32. var
  33.   i : integer;
  34. begin
  35.   port[$3C8] := $00;
  36.   for i := 0 to 255 do begin
  37.     port[$3C9] := pal[i].r*intensity div 63;
  38.     port[$3C9] := pal[i].g*intensity div 63;
  39.     port[$3C9] := pal[i].b*intensity div 63;
  40.   end;
  41. end;
  42.  
  43. procedure set_to_color(r,g,b,h: integer);
  44. var
  45.   i : integer;
  46. begin
  47.   port[$3C8] := $00;
  48.   for i := 0 to 255 do begin
  49.     port[$3C9] := pal[i].r+(r-pal[i].r)*h div 63;
  50.     port[$3C9] := pal[i].g+(g-pal[i].g)*h div 63;
  51.     port[$3C9] := pal[i].b+(b-pal[i].b)*h div 63;
  52.   end;
  53. end;
  54.  
  55. procedure fade_out(t : integer); {fades from pal to black}
  56. begin
  57.   for i := 63 downto 0 do begin waitretrace; set_intensity(i); delay(t); end;
  58. end;
  59.  
  60. procedure fade_in(t : integer);  {fades from black to pal}
  61. begin
  62.   for i := 0 to 63 do begin waitretrace; set_intensity(i); delay(t); end;
  63. end;
  64.  
  65. procedure flash_in(r,b,g: byte;t : integer); {fades from pal to color}
  66. begin
  67.   for i := 0 to 63 do begin waitretrace; set_to_color(r,b,g,i); delay(t); end;
  68. end;
  69.  
  70. procedure flash_out(r,g,b: byte;t : integer); {fades from color to pal}
  71. begin
  72.   for i := 63 downto 0 do begin waitretrace;set_to_color(r,g,b,i);delay(t);end;
  73. end;
  74.  
  75. BEGIN
  76.  
  77.   { Put some stuff on the screen }
  78.   SwapVectors;
  79.   Exec(GetEnv('COMSPEC'),' /c dir \ /w');
  80.   SwapVectors;
  81.   Get_Color(pal);
  82.   fade_out(50);
  83.   fade_in(50);
  84.   Flash_Out(100,16,32,50);
  85.   Flash_In (100,16,32,50);
  86.   ASM
  87.   MOV AX,00003h   {reset to textmode}
  88.   INT 010h
  89.   END;
  90.  
  91. END.